home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue46 / packages / DinoSource.Zip / CommonStuff.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-05-12  |  7.8 KB  |  248 lines
  1. unit CommonStuff;
  2.  
  3. {$ifdef Ver100} { Delphi 3.0x }
  4.   {$define DelphiLessThan4}
  5. {$endif}
  6. {$ifdef Ver110} { C++ Builder 3.0x }
  7.   {$define DelphiLessThan4}
  8. {$endif}
  9.  
  10. interface
  11.  
  12. uses
  13.   Menus, ComCtrls, ExtCtrls, Classes, Forms, Registry, SysUtils;
  14.  
  15. type
  16.   TIvoryHacker = class(TObject)
  17.   public
  18.     FInitialised: Boolean;
  19.     FTabControl: TTabControl; //Component palette
  20.     FPalettePopup: TPopupMenu; //Palette popup menu
  21.   {$ifndef DelphiLessThan4}
  22.     FControlBar: TControlBar; //Delphi's main window's control bar
  23.   {$endif}
  24.     FOptions: TMenuItem; //Archaeopteryx options menu item
  25.     Ini: TRegIniFile; //Used to save and restore options in registry
  26.     procedure DoAbout(Sender: TObject); //Shows About box
  27.     procedure AddOptionsItem; //Ensures Options item exists
  28.     constructor Create;
  29.     destructor Destroy; override;
  30.     procedure Setup;
  31.     procedure TidyUp;
  32.   end;
  33.  
  34. var
  35.   Stuff: TIvoryHacker;
  36.  
  37. //Locate a requested component object
  38. function GetComponent(Owner: TComponent; const Name, Error: String): TComponent;
  39.  
  40. //Warn user if an event that we chain is already chained
  41. procedure TestChainedEventHandler(OldHandler, NewHandler: Pointer);
  42.  
  43. procedure Register;
  44.  
  45. resourcestring
  46.   SSetupError = 'An error occurred in customising the IDE';
  47.   SGenericError = 'Cannot find requested component: ';
  48.   SAbout = '&About Archaeopteryx...';
  49.  
  50. const
  51. {$ifdef DelphiLessThan4}
  52.   SRegSection = 'Archaeopteryx';
  53. {$else}
  54.   SRegSection = '4.0';
  55. {$endif}
  56.  
  57. implementation
  58.  
  59. uses
  60.   Dialogs, Windows, Controls;
  61.  
  62. {$R Bitmap.Res}
  63.  
  64. resourcestring
  65.   SOptions = '&Options';
  66. {$ifndef DelphiLessThan4}
  67.   STabControlBar = 'ControlBar1'; //Component palette's control bar
  68. {$endif}
  69.   SAboutCaption = 'About Archaeopteryx';
  70.   SAboutMsg = 'Archaeopteryx.'#13#13 +
  71.     'Archaeopteryx (ahr-kee-ahp-tur-iks) is a prehistoric piece of' +
  72.     'software, dug out of the ground and restored by Oblong, ⌐ 1997.'#13#13 +
  73.     'This is freeware by the way - everyone''s doin'' it!'#13#13 +
  74.     'The source code for the Delphi 3 version of this ' +
  75.     'package accompanies an article on IDE customising in'#13 +
  76.     'The Delphi Magazine in November, 1997 (Issue 27)'#13#13;
  77.   SChainingWarning = 'IMPORTANT INFORMATION!!!'#13#13+
  78.     'The Archaeopteryx package has modified part of Delphi''s internals ' +
  79.     'in order to operate effectively. However it appears that another ' +
  80.     'add-in package has also done a similar POTENTIALLY conflicting ' +
  81.     'modification.'#13#13 +
  82.     'In order to avoid the POSSIBLE problems when removing your ' +
  83.     'add-in packages, ensure Archaeopteryx is uninstalled before ' +
  84.     'any of your previously installed packages.'#13#13 +
  85.     'Alternatively, uninstall Archaeopteryx now, followed by all ' +
  86.     'the other add-in packages and then re-install Archaeopteryx ' +
  87.     'first, followed by all the others'#13#13'Thank you';
  88.  
  89. const
  90.   SPaletteMenu = 'PaletteMenu'; //Component palette popup menu
  91.   STabControl = 'TabControl'; //Component palette
  92.   SIconName = 'Archaeopteryx'; //My Archaeopteryx icon resource
  93.   SImage = 'Image'; //Name of picture component on a message dialog
  94.   //Registry strings
  95.   SRegWarning = 'Warning';
  96. {$ifdef DelphiLessThan4}
  97.   SRegPath = 'Software\Oblong\';
  98. {$else}
  99.   SRegPath = 'Software\Oblong\Archaeopteryx';
  100. {$endif}
  101.  
  102. //Locates a component on the given Owner whose name matches that passed in
  103. //If the component cannot be found, an exception is raised with the string Error
  104. //unless RaiseExcept is False
  105. function GetComponent(Owner: TComponent; const Name, Error: String): TComponent;
  106. begin
  107.   Result := Owner.FindComponent(Name);
  108.   if not Assigned(Result) then
  109.     raise Exception.Create(Error);
  110. end;
  111.  
  112. procedure TestChainedEventHandler(OldHandler, NewHandler: Pointer);
  113. begin
  114.   //If the original (as designed) handler and
  115.   //the current handler of an event are not the same,
  116.   //then report the error to the user the first time
  117.   if (OldHandler <> NewHandler) and
  118.      Stuff.Ini.ReadBool(SRegSection, SRegWarning, True) then
  119.   begin
  120.     MessageDlg(SChainingWarning, mtWarning, [mbOk], 0);
  121.     //Set registry flag so the error is not reported again
  122.     Stuff.Ini.WriteBool(SRegSection, SRegWarning, False)
  123.   end
  124. end;
  125.  
  126. constructor TIvoryHacker.Create;
  127. begin
  128.   inherited Create;
  129. end;
  130.  
  131. destructor TIvoryHacker.Destroy;
  132. begin
  133.   TidyUp;
  134.   inherited Destroy
  135. end;
  136.  
  137. procedure TIvoryHacker.Setup;
  138. begin
  139.   //For registry access
  140.   Ini := TRegIniFile.Create(SRegPath);
  141.   //Locate various IDE components
  142.   FTabControl := GetComponent(Application.MainForm, STabControl, SGenericError + STabControl) as TTabControl;
  143.   FPalettePopup := GetComponent(Application.MainForm, SPaletteMenu, SGenericError + SPaletteMenu) as TPopupMenu;
  144. {$ifndef DelphiLessThan4}
  145.   FControlBar := GetComponent(Application.MainForm, STabControlBar, SGenericError + STabControlBar) as TControlBar;
  146. {$endif}
  147.   Stuff.FInitialised := True
  148. end;
  149.  
  150. procedure TIvoryHacker.TidyUp;
  151. begin
  152.   //Get rid of registry object
  153.   Ini.Free;
  154.   //If someone made an options menu, then get rid of it
  155.   FOptions.Free;
  156. end;
  157.  
  158. procedure TIvoryHacker.DoAbout(Sender: TObject);
  159.  
  160.   //Code to extract program version and file
  161.   //version from the current binary file
  162.   function VersionNumber: String;
  163.   var
  164.     VerInfo: Pointer;
  165.     Len, BufSize: {$ifdef DelphiLessThan4}Integer{$else}Cardinal{$endif};
  166.     Dest: PChar;
  167.     DestCodeInfo: ^LongRec;
  168.     LangCharSet: String;
  169.     FileName: array[0..Max_Path] of Char;
  170.   begin
  171.     Result := '';
  172.     //Find current binary file name
  173.     GetModuleFileName(HInstance, FileName, Max_Path);
  174.     //How big is version info?
  175.     BufSize := GetFileVersionInfoSize(FileName, Len);
  176.     if BufSize > 0 then
  177.     begin
  178.       //Reserve sufficient memory
  179.       GetMem(VerInfo, BufSize);
  180.       try
  181.         //Get version information
  182.         if GetFileVersionInfo(FileName, 0, BufSize, VerInfo) then
  183.         begin
  184.           //Get translation table
  185.           if VerQueryValue(VerInfo, '\VarFileInfo\Translation', Pointer(DestCodeInfo), Len) and
  186.              (Len >= 4) then { Translation table exists}
  187.             LangCharSet := Format('\StringFileInfo\%.4x%.4x\', [DestCodeInfo^.Lo, DestCodeInfo^.Hi]);
  188.           //Get ver. info. value via translation table
  189.           if VerQueryValue(VerInfo, PChar(LangCharSet + 'ProductVersion'), Pointer(Dest), Len) then
  190.             AppendStr(Result, 'Version ' + StrPas(Dest));
  191.           //Get ver. info. value via translation table
  192.           if VerQueryValue(VerInfo, PChar(LangCharSet + 'FileVersion'), Pointer(Dest), Len) then
  193.             AppendStr(Result, ' (Build ' + StrPas(Dest) + ')');
  194.         end
  195.       finally
  196.         //Free sufficient memory
  197.         FreeMem(VerInfo, BufSize);
  198.       end
  199.     end
  200.   end;
  201.  
  202. begin
  203.   //Would normally use MessageDlg, but I
  204.   //want to customise the icon, so use
  205.   //the more primitive CreateMessageDialog
  206.   with CreateMessageDialog(SAboutMsg + VersionNumber, mtInformation, [mbOk]) do
  207.     try
  208.       (FindComponent(SImage) as TImage).Picture.Icon.Handle :=
  209.         LoadIcon(HInstance, PChar(SIconName));
  210.       Caption := SAboutCaption;
  211.       ShowModal;
  212.     finally
  213.       Free
  214.     end;
  215. end;
  216.  
  217. procedure TIvoryHacker.AddOptionsItem;
  218. begin
  219.   if not FInitialised then
  220.     Setup;
  221.   //If another unit needs to add options items,
  222.   //they call this to add the main Options sub-menu
  223.   //just above the last menu item (Properties)
  224.   if not Assigned(FOptions) then
  225.   begin
  226.     FOptions := NewItem(SOptions, 0, False, True, nil, 0, '');
  227.     FPalettePopup.Items.Add(FOptions);
  228.     FOptions.MenuIndex := FPalettePopup.Items.Count - 1;
  229.   end;
  230. end;
  231.  
  232. procedure Register;
  233. begin
  234.   if not Stuff.FInitialised then
  235.     Stuff.Setup;
  236. end;
  237.  
  238. initialization
  239.   try
  240.     Stuff := TIvoryHacker.Create
  241.   except
  242.     on E: Exception do
  243.       ShowMessage(SSetupError + ': ' + E.Message)
  244.   end
  245. finalization
  246.   Stuff.Free;
  247. end.
  248.